home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / UCB Logo 3.0 ƒ / sources / standard source / wrksp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-08-14  |  22.7 KB  |  1,018 lines  |  [TEXT/ttxt]
  1. /*
  2.  *      wrksp.c         logo workspace management module                dvb
  3.  *
  4.  *    Copyright (C) 1993 by the Regents of the University of California
  5.  *
  6.  *      This program is free software; you can redistribute it and/or modify
  7.  *      it under the terms of the GNU General Public License as published by
  8.  *      the Free Software Foundation; either version 2 of the License, or
  9.  *      (at your option) any later version.
  10.  *  
  11.  *      This program is distributed in the hope that it will be useful,
  12.  *      but WITHOUT ANY WARRANTY; without even the implied warranty of
  13.  *      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14.  *      GNU General Public License for more details.
  15.  *  
  16.  *      You should have received a copy of the GNU General Public License
  17.  *      along with this program; if not, write to the Free Software
  18.  *      Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  *
  20.  */
  21.  
  22. #include "logo.h"
  23. #include "globals.h"
  24. #ifdef ibm
  25. #include "process.h"
  26. #endif
  27.  
  28. char *editor, *editorname;
  29. int to_pending = 0;
  30.  
  31. NODE *make_procnode(NODE *lst, NODE *wrds, short min, short df, short max)
  32. {
  33.     return(cons_list(0, lst, wrds, make_intnode((FIXNUM)min),
  34.              make_intnode((FIXNUM)df), make_intnode((FIXNUM)max),
  35.              END_OF_LIST));
  36. }
  37.  
  38. NODE *get_bodywords(NODE *proc, NODE *name)
  39. {
  40.     NODE *val = bodywords__procnode(proc);
  41.     NODE *head = NIL, *tail = NIL;
  42.  
  43.     if (val != NIL) return(val);
  44.     name = intern(name);
  45.     head = cons_list(0, (is_macro(name) ? Macro : To), name, END_OF_LIST);
  46.     tail = cdr(head);
  47.     val = formals__procnode(proc);
  48.     while (val != NIL) {
  49.     if (is_list(car(val)))
  50.         setcdr(tail, cons(cons(make_colon(caar(val)), cdar(val)), NIL));
  51.     else if (nodetype(car(val)) == INT)
  52.         setcdr(tail, cons(car(val),NIL));
  53.     else
  54.         setcdr(tail, cons(make_colon(car(val)),NIL));
  55.     tail = cdr(tail);
  56.     val = cdr(val);
  57.     }
  58.     head = cons(head, NIL);
  59.     tail = head;
  60.     val = bodylist__procnode(proc);
  61.     while (val != NIL) {
  62.     setcdr(tail, cons(car(val), NIL));
  63.     tail = cdr(tail);
  64.     val = cdr(val);
  65.     }
  66.     setcdr(tail, cons(End, NIL));
  67.     setbodywords__procnode(proc,head);
  68.     return(head);
  69. }
  70.  
  71. NODE *name_arg(NODE *args) {
  72.     while (aggregate(car(args)) && NOT_THROWING)
  73.     setcar(args, err_logo(BAD_DATA, car(args)));
  74.     return car(args);
  75. }
  76.  
  77. NODE *ltext(NODE *args)
  78. {
  79.     NODE *name, *val = UNBOUND;
  80.  
  81.     name = name_arg(args);
  82.     if (NOT_THROWING) {
  83.     val = procnode__caseobj(intern(name));
  84.     if (val == UNDEFINED) {
  85.         err_logo(DK_HOW_UNREC,name);
  86.         return UNBOUND;
  87.     } else if (is_prim(val)) {
  88.         err_logo(IS_PRIM,name);
  89.         return UNBOUND;
  90.     } else 
  91.         return text__procnode(val);
  92.     }
  93.     return UNBOUND;
  94. }
  95.  
  96. NODE *lfulltext(NODE *args)
  97. {
  98.     NODE *name, *val = UNBOUND;
  99.  
  100.     name = name_arg(args);
  101.     if (NOT_THROWING) {
  102.     val = procnode__caseobj(intern(name));
  103.     if (val == UNDEFINED) {
  104.         err_logo(DK_HOW_UNREC,name);
  105.         return UNBOUND;
  106.     } else if (is_prim(val)) {
  107.         err_logo(IS_PRIM,name);
  108.         return UNBOUND;
  109.     } else 
  110.         return get_bodywords(val,name);
  111.     }
  112.     return UNBOUND;
  113. }
  114.  
  115. NODE *define_helper(NODE *args, BOOLEAN macro_flag)
  116. {
  117.     NODE *name, *val, *arg = NIL;
  118.     int minimum = 0, deflt = 0, maximum = 0, old_default = -1;
  119.     int redef = (compare_node(valnode__caseobj(Redefp),True,TRUE) == 0);
  120.  
  121.     name = name_arg(args);
  122.     if (NOT_THROWING) {
  123.     name = intern(name);
  124.     val = procnode__caseobj(name);
  125.     if (!redef && is_prim(val)) {
  126.         err_logo(IS_PRIM,name);
  127.         return UNBOUND;
  128.     } else if (val != UNDEFINED) {
  129.         old_default = getint(dfltargs__procnode(val));
  130.     }
  131.     }
  132.     if (NOT_THROWING) {
  133.     val = cadr(args);
  134.     while ((val == NIL || !is_list(val) || !is_list(car(val))) &&
  135.             NOT_THROWING) {
  136.         setcar(cdr(args), err_logo(BAD_DATA, val));
  137.         val = cadr(args);
  138.     }
  139.     }
  140.     if (NOT_THROWING) {
  141.     args = car(val);
  142.     if (args != NIL) {
  143.         make_runparse(args);
  144.         args = parsed__runparse(args);
  145.     }
  146.     setcar(val, args);
  147.     while (args != NIL) {
  148.         arg = car(args);
  149.         if (arg != NIL && is_list(arg) && maximum != -1) {
  150.         make_runparse(arg);
  151.         arg = parsed__runparse(arg);
  152.         setcar(args, arg);
  153.         maximum++;
  154.         if (cdr(arg) == NIL)
  155.             maximum = -1;
  156.         } else if (nodetype(arg) == INT &&
  157.                getint(arg) <= (unsigned) maximum &&
  158.                getint(arg) >= minimum) {
  159.         deflt = getint(arg);
  160.         } else if (maximum == minimum) {
  161.         minimum++;
  162.         maximum++;
  163.         deflt++;
  164.         } else {
  165.         err_logo(BAD_DATA_UNREC, arg);
  166.         break;
  167.         }
  168.         args = cdr(args);
  169.         if (check_throwing) break;
  170.     }
  171.     }
  172.     if (NOT_THROWING) {
  173.     setprocnode__caseobj(name,
  174.                  make_procnode(val, NIL, minimum, deflt, maximum));
  175.     if (macro_flag)
  176.         setflag__caseobj(name, PROC_MACRO);
  177.     else
  178.         clearflag__caseobj(name, PROC_MACRO);
  179.     if (deflt != old_default && old_default >= 0) {
  180.         the_generation = reref(the_generation, cons(NIL, NIL));
  181.     }
  182.     }
  183.     return(UNBOUND);
  184. }
  185.  
  186. NODE *ldefine(NODE *args)
  187. {
  188.     return define_helper(args, FALSE);
  189. }
  190.  
  191. NODE *ldefmacro(NODE *args)
  192. {
  193.     return define_helper(args, TRUE);
  194. }
  195.  
  196. NODE *to_helper(NODE *args, BOOLEAN macro_flag)
  197. {
  198.     NODE *arg = NIL, *tnode = NIL, *proc_name, *formals = NIL, *lastnode = NIL,
  199.      *body_words, *lastnode2, *body_list;
  200.     int minimum = 0, deflt = 0, maximum = 0, old_default = -1;
  201.  
  202.     if (ufun != NIL && loadstream == stdin) {
  203.     err_logo(NOT_INSIDE,NIL);
  204.     return(UNBOUND);
  205.     }
  206.  
  207.     if (args == NIL) {
  208.     err_logo(NOT_ENOUGH,NIL);
  209.     return(UNBOUND);
  210.     }
  211.  
  212.     proc_name = car(args);
  213.     args = cdr(args);
  214.  
  215.     if (nodetype(proc_name) != CASEOBJ)
  216.     err_logo(BAD_DATA_UNREC, proc_name);
  217.     else if ((procnode__caseobj(proc_name) != UNDEFINED && loadstream == stdin)
  218.          || is_prim(procnode__caseobj(proc_name)))
  219.     err_logo(ALREADY_DEFINED, proc_name);
  220.     else {
  221.     NODE *old_proc = procnode__caseobj(proc_name);
  222.     if (old_proc != UNDEFINED) {
  223.         old_default = getint(dfltargs__procnode(old_proc));
  224.     }
  225.     while (args != NIL) {
  226.         arg = car(args);
  227.         args = cdr(args);
  228.         if (nodetype(arg) == CONS && maximum != -1) {
  229.         make_runparse(arg);
  230.         arg = parsed__runparse(arg);
  231.         maximum++;
  232.         if (nodetype(car(arg)) != COLON) {
  233.             err_logo(BAD_DATA_UNREC, arg);
  234.             break;
  235.         } else
  236.             setcar(arg, node__colon(car(arg)));
  237.         if (cdr(arg) == NIL)
  238.             maximum = -1;
  239.         } else if (nodetype(arg) == COLON && maximum == minimum) {
  240.         arg = node__colon(arg);
  241.         minimum++;
  242.         maximum++;
  243.         deflt++;
  244.         } else if (nodetype(arg) == INT && 
  245.                getint(arg) <= (unsigned) maximum &&
  246.                getint(arg) >= minimum) {
  247.         deflt = getint(arg);
  248.         } else {
  249.         err_logo(BAD_DATA_UNREC, arg);
  250.         break;
  251.         }
  252.         tnode = cons(arg, NIL);
  253.         if (formals == NIL) formals = tnode;
  254.         else setcdr(lastnode, tnode);
  255.         lastnode = tnode;
  256.     }
  257.     }
  258.  
  259.     if (NOT_THROWING) {
  260.     body_words = cons(current_line, NIL);
  261.     lastnode2 = body_words;
  262.     body_list = cons(formals, NIL);
  263.     lastnode = body_list;
  264.     to_pending++;    /* for int or quit signal */
  265.     while (NOT_THROWING && to_pending && (!feof(loadstream))) {
  266.         tnode = cons(reader(loadstream, "> "), NIL);
  267.         setcdr(lastnode2, tnode);
  268.         lastnode2 = tnode;
  269.         tnode = cons(parser(car(tnode), TRUE), NIL);
  270.         if (car(tnode) != NIL && compare_node(caar(tnode), End, TRUE) == 0)
  271.         break;
  272.         else if (car(tnode) != NIL) {
  273.         setcdr(lastnode, tnode);
  274.         lastnode = tnode;
  275.         }
  276.     }
  277.     if (to_pending && NOT_THROWING) {
  278.         setprocnode__caseobj(proc_name,
  279.                  make_procnode(body_list, body_words, minimum,
  280.                            deflt, maximum));
  281.         if (macro_flag)
  282.         setflag__caseobj(proc_name, PROC_MACRO);
  283.         else
  284.         clearflag__caseobj(proc_name, PROC_MACRO);
  285.         if (deflt != old_default && old_default >= 0) {
  286.         the_generation = reref(the_generation,
  287.                cons(NIL, NIL));
  288.         }
  289.         if (loadstream == stdin) {
  290.         ndprintf(stdout, "%s defined\n", proc_name);
  291.         }
  292.     }
  293.     to_pending = 0;
  294.     }
  295.     return(UNBOUND);
  296. }
  297.  
  298. NODE *lto(NODE *args)
  299. {
  300.     return to_helper(args, FALSE);
  301. }
  302.  
  303. NODE *lmacro(NODE *args)
  304. {
  305.     return to_helper(args, TRUE);
  306. }
  307.  
  308. NODE *lmake(NODE *args)
  309. {
  310.     NODE *what;
  311.  
  312.     what = name_arg(args);
  313.     if (NOT_THROWING) {
  314.     what = intern(what);
  315.     setvalnode__caseobj(what, cadr(args));
  316.     if (flag__caseobj(what, VAL_TRACED)) {
  317.         NODE *tvar = maybe_quote(cadr(args));
  318.         ndprintf(writestream, "Make %s %s", make_quote(what), tvar);
  319.         if (ufun != NIL) {
  320.         ndprintf(writestream, " in %s\n%s", ufun, this_line);
  321.         }
  322.         new_line(writestream);
  323.     }
  324.     }
  325.     return(UNBOUND);
  326. }
  327.  
  328. NODE *llocal(NODE *args)
  329. {
  330.     NODE *arg = NIL;
  331.     NODE *vsp = var_stack;
  332.  
  333.     if (tailcall == 1) return UNBOUND;
  334.     while (is_list(car(args)) && cdr(args) != NIL && NOT_THROWING)
  335.     setcar(args, err_logo(BAD_DATA, car(args)));
  336.     if (is_list(car(args)))
  337.     args = car(args);
  338.     while (args != NIL && NOT_THROWING) {
  339.     arg = car(args);
  340.     while (!is_word(arg) && NOT_THROWING) {
  341.         arg = err_logo(BAD_DATA, arg);
  342.         setcar(args, arg); /* prevent crash in lapply */
  343.     }
  344.     if (NOT_THROWING) {
  345.         arg = intern(arg);
  346.         setcar(args, arg); /* local [a b] faster next time */
  347.         if (not_local(arg,vsp)) {
  348.         push(arg, var_stack);
  349.         setobject(var_stack, valnode__caseobj(arg));
  350.         }
  351.         setvalnode__caseobj(arg, UNBOUND);
  352.         tell_shadow(arg);
  353.         args = cdr(args);
  354.     }
  355.     if (check_throwing) break;
  356.     }
  357.     var = reref(var, var_stack);    /* so eval won't undo our work */
  358.     return(UNBOUND);
  359. }
  360.  
  361. NODE *cnt_list = NIL;
  362. NODE *cnt_last = NIL;
  363. int want_buried = 0;
  364.  
  365. typedef enum {c_PROCS, c_VARS, c_PLISTS} CNTLSTTYP;
  366. CNTLSTTYP contents_list_type;
  367.  
  368. int bck(int flag)
  369. {
  370.     return (want_buried ? !flag : flag);
  371. }
  372.  
  373. void contents_map(NODE *sym)
  374. {
  375.     switch(contents_list_type) {
  376.     case c_PROCS:
  377.         if (procnode__object(sym) == UNDEFINED ||
  378.             is_prim(procnode__object(sym)))
  379.         return;
  380.         if (bck(flag__object(sym,PROC_BURIED))) return;
  381.         break;
  382.     case c_VARS:
  383.         if (valnode__object(sym) == UNBOUND) return;
  384.         if (bck(flag__object(sym,VAL_BURIED))) return;
  385.         break;
  386.     case c_PLISTS:
  387.         if (plist__object(sym) == NIL) return;
  388.         if (bck(flag__object(sym,PLIST_BURIED))) return;
  389.         break;
  390.     }
  391.     if (cnt_list == NIL) {
  392.     cnt_list = cons(canonical__object(sym), NIL);
  393.     cnt_last = vref(cnt_list);
  394.     } else {
  395.     setcdr(cnt_last, cons(canonical__object(sym), NIL));
  396.     cnt_last = cdr(cnt_last);
  397.     }
  398. }
  399.  
  400. void ms_listlist(NODE *nd)
  401. {
  402.     NODE *temp;
  403.  
  404.     while (nd != NIL) {
  405.     temp = newnode(CONS);
  406.     car(temp) = car(nd);
  407.     car(nd) = temp;
  408.     increfcnt(temp);
  409.     nd = cdr(nd);
  410.     }
  411. }
  412.  
  413. NODE *merge(NODE *a, NODE *b)
  414. {
  415.     NODE *ret, *tail;
  416.  
  417.     if (a == NIL) return(b);
  418.     if (b == NIL) return(a);
  419.     if (compare_node(car(a),car(b),FALSE) < 0) {
  420.     ret = a;
  421.     tail = a;
  422.     a = cdr(a);
  423.     } else {
  424.     ret = b;
  425.     tail = b;
  426.     b = cdr(b);
  427.     }
  428.  
  429.     while (a != NIL && b != NIL) {
  430.     if (compare_node(car(a),car(b),FALSE) < 0) {
  431.         cdr(tail) = a;
  432.         a = cdr(a);
  433.     } else {
  434.         cdr(tail) = b;
  435.         b = cdr(b);
  436.     }
  437.     tail = cdr(tail);
  438.     }
  439.  
  440.     if (b == NIL) cdr(tail) = a;
  441.     else cdr(tail) = b;
  442.  
  443.     return ret;
  444. }
  445.  
  446. NODE *mergepairs(NODE *nd) {
  447.     NODE *temp;
  448.  
  449.     while (nd != NIL && cdr(nd) != NIL) {
  450.     car(nd) = merge(car(nd), cadr(nd));
  451.     temp = cdr(nd);
  452.     cdr(nd) = cddr(nd);
  453.     car(temp) = cdr(temp) = NIL;
  454.     gc(temp);
  455.     nd = cdr(nd);
  456.     }
  457. }
  458.  
  459. NODE *mergesort(NODE *nd)
  460. {
  461.     NODE *ret;
  462.  
  463.     if (nd == NIL) return(NIL);
  464.     if (cdr(nd) == NIL) return(nd);
  465.     ms_listlist(nd);
  466.     while (cdr(nd) != NIL)
  467.     mergepairs(nd);
  468.     ret = car(nd);
  469.     car(nd) = NIL;
  470.     gc(nd);
  471.     return(ret);
  472. }
  473.  
  474. NODE *get_contents()
  475. {
  476.     deref(cnt_list);
  477.     cnt_list = NIL;
  478.     cnt_last = NIL;
  479.     map_oblist(contents_map);
  480.     cnt_list = mergesort(cnt_list);
  481.     return(cnt_list);
  482. }
  483.  
  484. NODE *lcontents()
  485. {
  486.     NODE *ret;
  487.  
  488.     want_buried = 0;
  489.  
  490.     contents_list_type = c_PLISTS;
  491.     ret = cons(get_contents(), NIL);
  492.     ref(ret);
  493.  
  494.     contents_list_type = c_VARS;
  495.     push(get_contents(), ret);
  496.  
  497.     contents_list_type = c_PROCS;
  498.     push(get_contents(), ret);
  499.  
  500.     deref(cnt_list);
  501.     cnt_list = NIL;
  502.     return(unref(ret));
  503. }
  504.  
  505. NODE *lburied()
  506. {
  507.     NODE *ret;
  508.  
  509.     want_buried = 1;
  510.  
  511.     contents_list_type = c_PLISTS;
  512.     ret = cons(get_contents(), NIL);
  513.     ref(ret);
  514.  
  515.     contents_list_type = c_VARS;
  516.     push(get_contents(), ret);
  517.  
  518.     contents_list_type = c_PROCS;
  519.     push(get_contents(), ret);
  520.  
  521.     deref(cnt_list);
  522.     cnt_list = NIL;
  523.     return(unref(ret));
  524. }
  525.  
  526. NODE *lprocedures()
  527. {
  528.     NODE *ret;
  529.  
  530.     want_buried = 0;
  531.  
  532.     contents_list_type = c_PROCS;
  533.     ret = get_contents();
  534.     ref(ret);
  535.     deref(cnt_list);
  536.     cnt_list = NIL;
  537.     return(unref(ret));
  538. }
  539.  
  540. NODE *lnames()
  541. {
  542.     NODE *ret;
  543.  
  544.     want_buried = 0;
  545.  
  546.     contents_list_type = c_VARS;
  547.     ret = cons(NIL, cons(get_contents(), NIL));
  548.     ref(ret);
  549.     deref(cnt_list);
  550.     cnt_list = NIL;
  551.     return(unref(ret));
  552. }
  553.  
  554. NODE *lplists()
  555. {
  556.     NODE *ret;
  557.  
  558.     want_buried = 0;
  559.  
  560.     contents_list_type = c_PLISTS;
  561.     ret = cons(NIL, cons(NIL, cons(get_contents(), NIL)));
  562.     ref(ret);
  563.     deref(cnt_list);
  564.     cnt_list = NIL;
  565.     return(unref(ret));
  566. }
  567.  
  568. NODE *one_list(NODE *nd)
  569. {
  570.     if (!is_list(nd))
  571.     return(cons(nd,NIL));
  572.     return nd;
  573. }
  574.  
  575. void three_lists(NODE *arg, NODE **proclst, NODE **varlst, NODE **plistlst)
  576. {
  577.     if (nodetype(car(arg)) == CONS)
  578.     arg = car(arg);
  579.  
  580.     if (!is_list(car(arg)))
  581.     *proclst = arg;
  582.     else {
  583.     *proclst = car(arg);
  584.     if (cdr(arg) != NIL) {
  585.         *varlst = one_list(cadr(arg));
  586.         if (cddr(arg) != NIL) {
  587.         *plistlst = one_list(car(cddr(arg)));
  588.         }
  589.     }
  590.     }
  591.     if (!is_list(*proclst) || !is_list(*varlst) || !is_list(*plistlst)) {
  592.     err_logo(BAD_DATA_UNREC,arg);
  593.     *plistlst = *varlst = *proclst = NIL;
  594.     }
  595. }
  596.  
  597. NODE *po_helper(NODE *arg, int just_titles)    /* >0 for POT, <0 for EDIT */
  598. {
  599.     NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL, *tvar = NIL;
  600.     NODE *plist;
  601.  
  602.     print_backslashes = TRUE;
  603.  
  604.     three_lists(arg, &proclst, &varlst, &plistlst);
  605.  
  606.     while (proclst != NIL) {
  607.     if (aggregate(car(proclst))) {
  608.         err_logo(BAD_DATA_UNREC, car(proclst));
  609.         break;
  610.     } else
  611.         tvar = procnode__caseobj(intern(car(proclst)));
  612.  
  613.     if (tvar == UNDEFINED) {
  614.         if (just_titles < 0) {
  615.         ndprintf(writestream,"to %p\nend\n\n", car(proclst));
  616.         } else {
  617.         err_logo(DK_HOW_UNREC, car(proclst));
  618.         break;
  619.         }
  620.     } else if (nodetype(tvar) == PRIM) {
  621.         err_logo(IS_PRIM, car(proclst));
  622.         break;
  623.     } else {
  624.         tvar = get_bodywords(tvar,car(proclst));
  625.         if (just_titles > 0)
  626.         print_nobrak(writestream, car(tvar));
  627.         else while (tvar != NIL) {
  628.         print_nobrak(writestream, car(tvar));
  629.         new_line(writestream);
  630.         tvar = cdr(tvar);
  631.         }
  632.         new_line(writestream);
  633.     }
  634.     proclst = cdr(proclst);
  635.     if (check_throwing) break;
  636.     }
  637.  
  638.     while (varlst != NIL && NOT_THROWING) {
  639.     if (aggregate(car(varlst))) {
  640.         err_logo(BAD_DATA_UNREC, car(varlst));
  641.         break;
  642.     } else
  643.         tvar = maybe_quote(valnode__caseobj(intern(car(varlst))));
  644.  
  645.     if (tvar == UNBOUND) {
  646.         if (just_titles >= 0) {
  647.         err_logo(NO_VALUE, car(varlst));
  648.         break;
  649.         }
  650.     } else {
  651.         ndprintf(writestream, "Make %s %s\n",
  652.              make_quote(car(varlst)), tvar);
  653.     }
  654.     varlst = cdr(varlst);
  655.     if (check_throwing) break;
  656.     }
  657.  
  658.     while (plistlst != NIL && NOT_THROWING) {
  659.     if (aggregate(car(plistlst))) {
  660.         err_logo(BAD_DATA_UNREC, car(plistlst));
  661.         break;
  662.     } else {
  663.         plist = plist__caseobj(intern(car(plistlst)));
  664.         if (plist != NIL && just_titles > 0) {
  665.         ndprintf(writestream, "Plist %s = %s\n",
  666.              maybe_quote(car(plistlst)), plist);
  667.         } else while (plist != NIL) {
  668.         ndprintf(writestream, "Pprop %s %s %s\n",
  669.              maybe_quote(car(plistlst)),
  670.              maybe_quote(car(plist)),
  671.              maybe_quote(cadr(plist)));
  672.         plist = cddr(plist);
  673.         }
  674.     }
  675.     plistlst = cdr(plistlst);
  676.     if (check_throwing) break;
  677.     }
  678.  
  679.     print_backslashes = FALSE;
  680.     return(UNBOUND);
  681. }
  682.  
  683. NODE *lpo(NODE *arg)
  684. {
  685.     return(po_helper(arg,0));
  686. }
  687.  
  688. NODE *lpot(NODE *arg)
  689. {
  690.     return(po_helper(arg,1));
  691. }
  692.  
  693. NODE *lerase(NODE *arg)
  694. {
  695.     NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL;
  696.     NODE *nd;
  697.     int redef = (compare_node(valnode__caseobj(Redefp),True,TRUE) == 0);
  698.  
  699.     three_lists(arg, &proclst, &varlst, &plistlst);
  700.  
  701.     if (proclst != NIL)
  702.     the_generation = reref(the_generation, cons(NIL, NIL));
  703.  
  704.     while (proclst != NIL) {
  705.     if (aggregate(car(proclst))) {
  706.         err_logo(BAD_DATA_UNREC, car(proclst));
  707.         break;
  708.     }
  709.     nd = intern(car(proclst));
  710.     if (!redef && is_prim(procnode__caseobj(nd))) {
  711.         err_logo(IS_PRIM, nd);
  712.         break;
  713.     }
  714.     setprocnode__caseobj(nd, UNDEFINED);
  715.     proclst = cdr(proclst);
  716.     }
  717.  
  718.     while (varlst != NIL && NOT_THROWING) {
  719.     if (aggregate(car(varlst))) {
  720.         err_logo(BAD_DATA_UNREC, car(varlst));
  721.         break;
  722.     }
  723.     setvalnode__caseobj(intern(car(varlst)), UNBOUND);
  724.     varlst = cdr(varlst);
  725.     }
  726.  
  727.     while (plistlst != NIL && NOT_THROWING) {
  728.     if (aggregate(car(plistlst))) {
  729.         err_logo(BAD_DATA_UNREC, car(plistlst));
  730.         break;
  731.     }
  732.     setplist__caseobj(intern(car(plistlst)), NIL);
  733.     plistlst = cdr(plistlst);
  734.     }
  735.     return(UNBOUND);
  736. }
  737.  
  738. NODE *bury_helper(NODE *arg, int flag)
  739. {
  740.     NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL;
  741.  
  742.     three_lists(arg, &proclst, &varlst, &plistlst);
  743.  
  744.     while (proclst != NIL) {
  745.     if (aggregate(car(proclst))) {
  746.         err_logo(BAD_DATA_UNREC, car(proclst));
  747.         break;
  748.     }
  749.     setflag__caseobj(intern(car(proclst)), flag);
  750.     proclst = cdr(proclst);
  751.     if (check_throwing) break;
  752.     }
  753.  
  754.     flag <<= 1;
  755.     while (varlst != NIL && NOT_THROWING) {
  756.     if (aggregate(car(varlst))) {
  757.         err_logo(BAD_DATA_UNREC, car(varlst));
  758.         break;
  759.     }
  760.     setflag__caseobj(intern(car(varlst)), flag);
  761.     varlst = cdr(varlst);
  762.     if (check_throwing) break;
  763.     }
  764.  
  765.     flag <<= 1;
  766.     while (plistlst != NIL && NOT_THROWING) {
  767.     if (aggregate(car(plistlst))) {
  768.         err_logo(BAD_DATA_UNREC, car(plistlst));
  769.         break;
  770.     }
  771.     setflag__caseobj(intern(car(plistlst)), flag);
  772.     plistlst = cdr(plistlst);
  773.     if (check_throwing) break;
  774.     }
  775.     return(UNBOUND);
  776. }
  777.  
  778. NODE *lbury(NODE *arg)
  779. {
  780.     return bury_helper(arg,PROC_BURIED);
  781. }
  782.  
  783. NODE *ltrace(NODE *arg)
  784. {
  785.     return bury_helper(arg,PROC_TRACED);
  786. }
  787.  
  788. NODE *lstep(NODE *arg)
  789. {
  790.     return bury_helper(arg,PROC_STEPPED);
  791. }
  792.  
  793. NODE *unbury_helper(NODE *arg, int flag)
  794. {
  795.     NODE *proclst = NIL, *varlst = NIL, *plistlst = NIL;
  796.  
  797.     three_lists(arg, &proclst, &varlst, &plistlst);
  798.  
  799.     while (proclst != NIL) {
  800.     if (aggregate(car(proclst))) {
  801.         err_logo(BAD_DATA_UNREC, car(proclst));
  802.         break;
  803.     }
  804.     clearflag__caseobj(intern(car(proclst)), flag);
  805.     proclst = cdr(proclst);
  806.     if (check_throwing) break;
  807.     }
  808.  
  809.     flag <<= 1;
  810.     while (varlst != NIL && NOT_THROWING) {
  811.     if (aggregate(car(varlst))) {
  812.         err_logo(BAD_DATA_UNREC, car(varlst));
  813.         break;
  814.     }
  815.     clearflag__caseobj(intern(car(varlst)), flag);
  816.     varlst = cdr(varlst);
  817.     if (check_throwing) break;
  818.     }
  819.  
  820.     flag <<= 1;
  821.     while (plistlst != NIL && NOT_THROWING) {
  822.     if (aggregate(car(plistlst))) {
  823.         err_logo(BAD_DATA_UNREC, car(plistlst));
  824.         break;
  825.     }
  826.     clearflag__caseobj(intern(car(plistlst)), flag);
  827.     plistlst = cdr(plistlst);
  828.     if (check_throwing) break;
  829.     }
  830.     return(UNBOUND);
  831. }
  832.  
  833. NODE *lunbury(NODE *arg)
  834. {
  835.     return unbury_helper(arg,PROC_BURIED);
  836. }
  837.  
  838. NODE *luntrace(NODE *arg)
  839. {
  840.     return unbury_helper(arg,PROC_TRACED);
  841. }
  842.  
  843. NODE *lunstep(NODE *arg)
  844. {
  845.     return unbury_helper(arg,PROC_STEPPED);
  846. }
  847.  
  848. NODE *ledit(NODE *args)
  849. {
  850.     char tmp_filename[30];
  851.     FILE *holdstrm;
  852. #ifdef unix
  853.     extern int getpid();
  854. #endif
  855. #ifdef ibm
  856.     BOOLEAN was_graphics;
  857. #endif
  858.     NODE *tmp_line = NIL, *exec_list = NIL;
  859.     int sv_val_status = val_status;
  860.  
  861. #ifndef unix
  862.     sprintf(tmp_filename, "temp.txt");
  863. #else
  864.     sprintf(tmp_filename, "/tmp/logo%d", getpid());
  865. #endif
  866.     if (args != NIL) {
  867.     holdstrm = writestream;
  868.     writestream = fopen(tmp_filename, "w");
  869.     if (writestream != NULL) {
  870.         po_helper(args,-1);
  871.         fclose(writestream);
  872.         writestream = holdstrm;
  873.     } else {
  874.         err_logo(FILE_ERROR,
  875.           make_static_strnode("Could not create editor file"));
  876.         writestream = holdstrm;
  877.         return(UNBOUND);
  878.     }
  879.     }
  880. #ifdef mac
  881.     if (!mac_edit()) return(UNBOUND);
  882. #else
  883. #ifdef ibm
  884.     was_graphics = in_graphics_mode;
  885.     if (in_graphics_mode) t_screen();
  886. #ifdef __ZTC__
  887.     zflush();
  888. #endif
  889.     if (spawnlp(P_WAIT, editor, editorname, tmp_filename, NULL)) {
  890.     err_logo(FILE_ERROR, make_static_strnode
  891.          ("Could not launch the editor"));
  892.     return(UNBOUND);
  893.     }
  894.     if (was_graphics) s_screen();
  895.     else lcleartext();
  896. #else
  897.     if (fork() == 0) {
  898.     execlp(editor, editorname, tmp_filename, 0);
  899.     exit(1);
  900.     }
  901.     wait(0);
  902. #endif
  903. #endif
  904.     holdstrm = loadstream;
  905.     tmp_line = reref(tmp_line, current_line);
  906.     loadstream = fopen(tmp_filename, "r");
  907.     if (loadstream != NULL) {
  908.     while (!feof(loadstream) && NOT_THROWING) {
  909.         current_line = reref(current_line, reader(loadstream, ""));
  910.         exec_list = parser(current_line, TRUE);
  911.         val_status = 0;
  912.         if (exec_list != NIL) eval_driver(exec_list);
  913.     }
  914.     fclose(loadstream);
  915.     val_status = sv_val_status;
  916.     } else
  917.     err_logo(FILE_ERROR,
  918.           make_static_strnode("Could not read editor file"));
  919.     loadstream = holdstrm;
  920.     current_line = reref(current_line, tmp_line);
  921.     return(UNBOUND);
  922. }
  923.  
  924. NODE *lthing(NODE *args)
  925. {
  926.     NODE *val = UNBOUND, *arg;
  927.  
  928.     arg = name_arg(args);
  929.     if (NOT_THROWING) val = valnode__caseobj(intern(arg));
  930.     while (val == UNBOUND && NOT_THROWING)
  931.     val = err_logo(NO_VALUE, car(args));
  932.     return(val);
  933. }
  934.  
  935. NODE *lnamep(NODE *args)
  936. {
  937.     NODE *arg;
  938.  
  939.     arg = name_arg(args);
  940.     if (NOT_THROWING) 
  941.     return torf(valnode__caseobj(intern(arg)) != UNBOUND);
  942.     return UNBOUND;
  943. }
  944.  
  945. NODE *lprocedurep(NODE *args)
  946. {
  947.     NODE *arg;
  948.  
  949.     arg = name_arg(args);
  950.     if (NOT_THROWING) 
  951.     return torf(procnode__caseobj(intern(arg)) != UNDEFINED);
  952.     return UNBOUND;
  953. }
  954.  
  955. NODE *check_proctype(NODE *args, int wanted)
  956. {
  957.     NODE *arg,*cell;
  958.     int isprim;
  959.  
  960.     arg = name_arg(args);
  961.     if (NOT_THROWING && (cell = procnode__caseobj(intern(arg))) == UNDEFINED) {
  962.     return(False);
  963.     }
  964.     if (wanted == 2) return torf(is_macro(intern(arg)));
  965.     isprim = is_prim(cell);
  966.     if (NOT_THROWING) return torf((isprim != 0) == wanted);
  967.     return(UNBOUND);
  968. }
  969.  
  970. NODE *lprimitivep(NODE *args)
  971. {
  972.     return(check_proctype(args,1));
  973. }
  974.  
  975. NODE *ldefinedp(NODE *args)
  976. {
  977.     return(check_proctype(args,0));
  978. }
  979.  
  980. NODE *lmacrop(NODE *args)
  981. {
  982.     return(check_proctype(args,2));
  983. }
  984.  
  985. NODE *lcopydef(NODE *args)
  986. {
  987.     NODE *arg1, *arg2;
  988.     int redef = (compare_node(valnode__caseobj(Redefp),True,TRUE) == 0);
  989.  
  990.     arg1 = name_arg(args);
  991.     arg2 = name_arg(cdr(args));
  992.     if (numberp(arg2)) err_logo(BAD_DATA_UNREC, arg2);
  993.     if (numberp(arg1)) err_logo(BAD_DATA_UNREC, arg1);
  994.     if (NOT_THROWING) {
  995.     arg1 = intern(arg1);
  996.     arg2 = intern(arg2);
  997.     }
  998.     if (NOT_THROWING && procnode__caseobj(arg2) == UNDEFINED)
  999.     err_logo(DK_HOW, arg2);
  1000.     if (NOT_THROWING && !redef && is_prim(procnode__caseobj(arg1)))
  1001.     err_logo(IS_PRIM, arg1);
  1002.     if (NOT_THROWING) {
  1003.     NODE *old_proc = procnode__caseobj(arg1);
  1004.     NODE *new_proc = procnode__caseobj(arg2);
  1005.     if (old_proc != UNDEFINED) {
  1006.         if (getint(dfltargs__procnode(old_proc)) !=
  1007.             getint(dfltargs__procnode(new_proc))) {
  1008.         the_generation = reref(the_generation, cons(NIL, NIL));
  1009.         }
  1010.     }
  1011.     setprocnode__caseobj(arg1, new_proc);
  1012.     setflag__caseobj(arg1, PROC_BURIED);
  1013.     if (is_macro(arg2)) setflag__caseobj(arg1, PROC_MACRO);
  1014.     else clearflag__caseobj(arg1, PROC_MACRO);
  1015.     }
  1016.     return(UNBOUND);
  1017. }
  1018.